home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / IO.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  8.0 KB  |  239 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; io
  3.  
  4. (provide 'io)
  5. (require 'format-long "long")
  6. (require 'msg)
  7. (require 'personality "personal")
  8. (require 'string)
  9. (require 'type)
  10.  
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ; display
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15.  
  16. (defun display (string &key echo-stream)
  17.   (princ string)
  18.   (and echo-stream (princ string echo-stream)))
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ; read-non-empty-line
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defun read-non-empty-line ()
  25.   (prog (result)
  26.    loop (setq result (read-line))
  27.         (if (= (length result) 0)
  28.             (go loop))
  29.         (return result)))
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ; ask
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34.  
  35. (defun ask (&key (type t) echo-stream default prompt quit-tag)
  36.   ; typep from the type module
  37.   (loop 
  38.    (let* ((result (prompt-with-default
  39.                    :default default
  40.                    :type type
  41.                    :prompt prompt
  42.                    :quit-tag quit-tag
  43.                    :echo-stream echo-stream))
  44.           (done (typep result type)))
  45.      (if done
  46.        (return result)                ; This is the exit from the loop
  47.        (insist-upon-correct-type type
  48.                                  :echo-stream echo-stream
  49.                                  :quittable? quit-tag)))))
  50.  
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52. ; get-char
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54.  
  55. (defun get-char () (int-char (get-key)))
  56.  
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. ; y-or-n-p
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60.  
  61. (defun y-or-n-p (&key prompt)
  62.   (if prompt (princ prompt))
  63.   (let ((result (get-one-of-these-characters '(#\y #\Y #\n #\N))))
  64.     (if (member result '(#\y #\Y))
  65.         (progn (princ "Yes") (terpri) t)
  66.         (progn (princ "No") (terpri) nil))))
  67.  
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69. ; 
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71.  
  72. (defun display-array (arr)
  73.   (for i 0 (1- (length arr)) (msg "[" i "]: " (aref arr i) t)))
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ; format-prompt
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (defun format-prompt (&key prompt default line-length quit-tag)
  80.   (let ((default-in-a-box (if default
  81.                   (format nil " [DEFAULT=~A]" default)
  82.                 ""))
  83.     (prompt-string (zap-to-string prompt))
  84.     (quit-string (if quit-tag " or QUIT" "")))
  85.     (format-text-if-its-too-long
  86.      (concatenate 'string prompt-string default-in-a-box quit-string)
  87.      line-length)))
  88.  
  89. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90. ; insist-upon-correct-type
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92.  
  93. (defun insist-upon-correct-type (type &key echo-stream quittable?)
  94.   (chastise-careless-users)
  95.   (let ((pretty (format nil "Input should be ~A~A~%"
  96.                   (type-pretty-print-string type)
  97.                   (if quittable? " or QUIT" ""))))
  98.     (format t pretty)
  99.     (if echo-stream (format echo-stream pretty))))
  100.  
  101.  
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. ; chastise-careless-users
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105.  
  106. (defun chastise-careless-users ()
  107.   (let ((message (chastise-careless-users-string)))
  108.     (if (> (length message) 0)
  109.         (format t "~A~%"
  110.                 (format-text-if-its-too-long message (line-length))))))
  111.  
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113. ; line-length
  114. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  115.  
  116. (defun line-length () *line-length*)
  117.  
  118. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  119. ; display-numbered-menu
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121.  
  122. (defun display-numbered-menu (menu &key special echo-stream)
  123.   (let ((s (numbered-list-string menu :special special :indent 2)))
  124.     (format t s)
  125.     (if echo-stream (format echo-stream s))))
  126.  
  127. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  128. ; prompt-with-default
  129. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  130.  
  131. (defun prompt-with-default
  132.   (&key type echo-stream prompt default quit-tag)
  133.   (let* ((entire-prompt (format-prompt :prompt prompt
  134.                        :default default
  135.                        :line-length (line-length)
  136.                        :quit-tag quit-tag))
  137.          (result
  138.           (block outer
  139.             (format t "~A~%" entire-prompt)
  140.             (if echo-stream (format echo-stream "~A~%" entire-prompt))
  141.             (if default
  142.               (if (equal (peek-char) #\newline)
  143.                 (progn (read-char)
  144.                        (return-from outer default))))
  145.  
  146.             (let ((impurity (read-line)))
  147.               (test-for-quit impurity quit-tag echo-stream)
  148.               (case type
  149.                 (string impurity)
  150.                 (t (read-from-string impurity)))))))
  151.  
  152.               
  153.     (if echo-stream (format echo-stream "~A~%" result))
  154.     (test-for-quit result quit-tag echo-stream)
  155.     result))
  156.  
  157. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  158. ; quit-p
  159. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  160.  
  161. (defun quit-p (r)
  162.   (let ((s (zap-to-string r)))
  163.     (if (> (length s) 3)
  164.         (string-equal (string-upcase (subseq s 0 4))
  165.                       "QUIT"))))
  166.  
  167. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  168. ; test-for-quit
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170.  
  171. (defun test-for-quit (input quit-tag echo-stream)
  172.   (if (and quit-tag (quit-p input))
  173.       (progn
  174.         (if echo-stream
  175.             (format echo-stream "QUIT!~%"))
  176.         (throw quit-tag t))))
  177.  
  178.  
  179. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  180. ; get-menu-pick-index
  181. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  182. ; returns a zero-origin index to menu
  183.  
  184. (defun get-menu-pick-index
  185.   (menu &key title echo-stream default special quit-tag)
  186.   (let* ((ul-prompt "Enter the number of one menu entry")
  187.          (menu-big (length menu)))
  188.       (if title
  189.         (progn (format t "~A~%" title)
  190.                (if echo-stream (format echo-stream "~A~%" title))))
  191.       (display-numbered-menu menu
  192.         :echo-stream echo-stream
  193.         :special special)
  194.       (1-
  195.         (ask :prompt ul-prompt
  196.              :type `(integer 1 ,menu-big)
  197.              :echo-stream echo-stream
  198.              :default default
  199.              :quit-tag quit-tag))))
  200.  
  201. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  202. ; get-menu-pick
  203. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  204.  
  205. (defun get-menu-pick
  206.   (menu &key title echo-stream default special quit-tag)
  207.   (let ((index (get-menu-pick-index menu
  208.                                     :title title
  209.                                     :echo-stream echo-stream
  210.                                     :default default
  211.                     :special special
  212.                     :quit-tag quit-tag)))
  213.     (elt menu index)))
  214.  
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216. ; get-one-of-these-characters
  217. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  218.  
  219. (defun get-one-of-these-characters (character-bag)
  220.   (let ((done nil)
  221.         (result nil))
  222.     (while (not done)
  223.       (setq result (get-char))
  224.       (write-char result)
  225.       (terpri)
  226.       (if (member result character-bag)
  227.           (setq done t)
  228.           (progn
  229.             (chastise-careless-users)
  230.             (format t "~A~%"
  231.               (format-text-if-its-too-long
  232.                 (format nil
  233.                   "Please enter one of {~A}"
  234.                   (apply #'concatenate
  235.                     (cons 'string
  236.                       (mapcar #'zap-to-string character-bag))))
  237.                 (line-length))))))
  238.     result))
  239.